home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / w3-widget.el.z / w3-widget.el
Encoding:
Text File  |  1998-05-21  |  13.4 KB  |  387 lines
  1. ;;; w3-widget.el --- An image widget
  2. ;; Author: wmperry
  3. ;; Created: 1997/11/03 17:25:33
  4. ;; Version: 1.33
  5. ;; Keywords: faces, images
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993 - 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is part of GNU Emacs.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;; This is a widget that will do the best it can with an image.
  31. ;;;
  32. ;;; It can handle all the common occurences of images on the world wide web
  33. ;;; 1. A plain image - displays either a glyph of the image, or the
  34. ;;;    alternative text
  35. ;;; 2. A hyperlinked image - an image that is also a hypertext link to
  36. ;;;    another page.  Displays either a glyph of the image, or the
  37. ;;;    alternative text.  When activated with the mouse or the keyboard,
  38. ;;;    the 'href' property of the widget is retrieved.
  39. ;;; 3. Server side imagemaps - an image that has hotzones that lead to
  40. ;;;    different areas.  Unfortunately, we cannot tell where the links go
  41. ;;;    from the client - all processing is done by the server.  Displays
  42. ;;;    either a glyph of the image, or the alternative text.  When activated
  43. ;;;    with the mouse or the keyboard, the coordinates clicked on are
  44. ;;;    sent to the remote server as HREF?x,y.  If the link is activated
  45. ;;;    by the keyboard, then 0,0 are sent as the coordinates.
  46. ;;; 4. Client side imagemaps - an image that has hotzones that lead to
  47. ;;;    different areas.  All processing is done on the client side, so
  48. ;;;    we can actually show a decent representation on a TTY.  Displays
  49. ;;;    either a glyph of the image, or a drop-down-list of the destinations
  50. ;;;    These are either URLs (http://foo/...) or alternative text.
  51. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  52.  
  53. (require 'cl)
  54. (require 'widget)
  55. (require 'w3-keyword)
  56.  
  57. (defvar widget-image-keymap (make-sparse-keymap)
  58.   "Keymap used over glyphs in an image widget")
  59.  
  60. (defconst widget-mouse-button1 nil)
  61. (defconst widget-mouse-button2 nil)
  62. (defconst widget-mouse-button3 nil)
  63.  
  64. (if (string-match "XEmacs" (emacs-version))
  65.     (if (featurep 'mouse)
  66.     (setq widget-mouse-button1 'button1
  67.           widget-mouse-button2 'button2
  68.           widget-mouse-button3 'button3)
  69.       (setq widget-mouse-button1 'return
  70.         widget-mouse-button2 'return
  71.         widget-mouse-button3 'return))
  72.   (setq widget-mouse-button1 'mouse-1
  73.     widget-mouse-button2 'mouse-2
  74.     widget-mouse-button3 'mouse-3))
  75.  
  76. (defvar widget-image-inaudible-p nil
  77.   "*Whether to make images inaudible or not.")
  78.  
  79. (define-key widget-image-keymap (vector widget-mouse-button1)
  80.   'widget-image-button-press)
  81. (define-key widget-image-keymap (vector widget-mouse-button2)
  82.   'widget-image-button-press)
  83.   
  84. (define-widget 'image 'default
  85.   "A fairly complex image widget."
  86.   :convert-widget 'widget-image-convert
  87.   :value-to-internal (lambda (widget value) value)
  88.   :value-to-external (lambda (widget value) value)
  89.   :value-set 'widget-image-value-set
  90.   :create 'widget-image-create
  91.   :delete 'widget-image-delete
  92.   :value-create 'widget-image-value-create
  93.   :value-delete 'widget-image-value-delete
  94.   :value-get 'widget-image-value-get
  95.   :notify 'widget-image-notify
  96.   )
  97.  
  98. (defun widget-image-convert (widget)
  99.   (let ((args (widget-get widget :args)))
  100.     (widget-put widget :args nil)
  101.     (while args
  102.       (widget-put widget (car args) (cadr args))
  103.       (setq args (cddr args)))
  104.     widget))
  105.  
  106. (defun widget-image-value-get (widget)
  107.   (let ((children (widget-get widget :children)))
  108.     (and (car children)
  109.      (widget-apply (car children) :value-get))))
  110.  
  111. (defun widget-image-create (widget)
  112.   ;; Create an image widget at point in the current buffer
  113.   (let ((where (widget-get widget 'where)))
  114.     (cond
  115.      ((null where)
  116.       (setq where (set-marker (make-marker) (point))))
  117.      ((markerp where)
  118.       nil)
  119.      ((integerp where)
  120.       (setq where (set-marker (make-marker) where)))
  121.      (t
  122.       (error "IMPOSSIBLE position in widget-image-create: %s" where)))
  123.     (widget-put widget 'where where))
  124.   (widget-image-value-create widget))
  125.  
  126. (defun widget-image-value-set (widget value)
  127.   ;; Recreate widget with new value.
  128.   (save-excursion
  129.     (widget-image-delete widget)
  130.     (if (widget-glyphp value)
  131.     (widget-put widget 'glyph value)
  132.       (widget-put widget :value value))
  133.     (put-text-property (point)
  134.                (progn
  135.              (widget-apply widget :create)
  136.              (point))
  137.                'inaudible
  138.                widget-image-inaudible-p)))
  139.  
  140. (defsubst widget-image-usemap (widget)
  141.   (let ((usemap (widget-get widget 'usemap)))
  142.     (if (listp usemap)
  143.     usemap
  144.       (if (and usemap (string-match "^#" usemap))
  145.       (setq usemap (substring usemap 1 nil)))
  146.       (cdr-safe (assoc usemap w3-imagemaps)))))
  147.  
  148. (defun widget-image-callback (widget widget-ignore &optional event)
  149.   (if (widget-get widget :href)
  150.       (w3-fetch (widget-get widget :href) (widget-get widget :target))))
  151.  
  152. (defmacro widget-image-create-subwidget (&rest args)
  153.   (` (widget-create (,@ args)
  154.             :parent widget
  155.             :help-echo 'widget-image-summarize
  156.             'usemap (widget-get widget 'usemap)
  157.             :href href
  158.             :target target
  159.             :src (widget-get widget :src)
  160.             'ismap server-map)))
  161.  
  162. (defun widget-image-value-create (widget)
  163.   ;; Insert the printed representation of the value
  164.   (let (
  165.     (href (widget-get widget :href))
  166.     (target (widget-get widget :target))
  167.     (face (widget-get widget :button-face))
  168.     (server-map (widget-get widget 'ismap))
  169.     (client-map (widget-image-usemap widget))
  170.     (where (or (widget-get widget 'where) (point)))
  171.     (glyph (widget-get widget 'glyph))
  172.     (alt (widget-get widget 'alt))
  173.     (real-widget nil)
  174.     (invalid-glyph nil)
  175.     )
  176.     (if target (setq target (intern (downcase target))))
  177.  
  178.     ;; Specifier-instance will signal an error if we have an invalid
  179.     ;; image specifier, which would be the case if we get screwed up
  180.     ;; data back from a URL somewhere.
  181.     
  182.     (setq invalid-glyph (and glyph (condition-case ()
  183.                        (if (specifier-instance
  184.                         (glyph-image glyph))
  185.                        nil)
  186.                      (error t))))
  187.     (if (or (not glyph) invalid-glyph)
  188.     ;; Do a TTY or delayed image version of the image.
  189.     (save-excursion
  190.       (if (= 0 (length alt)) (setq alt nil))
  191.       (goto-char where)
  192.       (cond
  193.        (client-map
  194.         (let* ((default nil)
  195.            (options (mapcar
  196.                  (function
  197.                   (lambda (x)
  198.                 (if (eq (aref x 0) 'default)
  199.                     (setq default (aref x 2)))
  200.                 (if (and (not default) (stringp (aref x 2)))
  201.                     (setq default (aref x 2)))
  202.                 (list 'choice-item
  203.                       :tab-order -1
  204.                       :delete 'widget-default-delete
  205.                       :format "%[%t%]"
  206.                       :tag (or (aref x 3) (aref x 2))
  207.                       :value (aref x 2)))) client-map)))
  208.           (setq real-widget
  209.             (apply 'widget-create 'menu-choice
  210.                :tag (or (widget-get widget :tag) alt "Imagemap")
  211.                :button-face face
  212.                :format "%[%t:%v%]"
  213.                :ignore-case t
  214.                :notify (widget-get widget :notify)
  215.                :delete 'widget-default-delete
  216.                :action (widget-get widget :action)
  217.                :value default
  218.                :parent widget
  219.                :help-echo 'widget-image-summarize
  220.                options))))
  221.        ((and server-map (stringp href))
  222.         (setq real-widget
  223.           (widget-image-create-subwidget
  224.            'item :format "%[%t%]"
  225.            :tag alt
  226.            :button-face face
  227.            :delete 'widget-default-delete
  228.            :value href
  229.            :action (widget-get widget :action)
  230.            :notify (widget-get widget :notify))))
  231.        (href
  232.         (setq real-widget
  233.           (widget-image-create-subwidget
  234.            'item :format "%[%t%]"
  235.            :tag (or alt "Image")
  236.            :button-face face
  237.            :value href
  238.            :delete 'widget-default-delete
  239.            :action (widget-get widget :action)
  240.            :notify 'widget-image-callback)))
  241.        (alt
  242.         (setq real-widget
  243.           (widget-image-create-subwidget
  244.            'item :format "%[%t%]"
  245.            :tag alt
  246.            :button-face face
  247.            :tab-order -1
  248.            :delete 'widget-default-delete
  249.            :action (widget-get widget :action)
  250.            :notify 'widget-image-callback))))
  251.       (if (not real-widget)
  252.           nil
  253.         (widget-put widget :children (list real-widget))))
  254.       ;;; Actually use the image
  255.       (let ((extent (or (widget-get widget 'extent)
  256.             (make-extent where where))))
  257.     (set-extent-endpoints extent where where)
  258.     (widget-put widget 'extent extent)
  259.     (widget-put widget :children nil)
  260.     (set-extent-property extent 'keymap widget-image-keymap)
  261.     (set-extent-property extent 'begin-glyph glyph)
  262.     (set-extent-property extent 'detachable t)
  263.     (set-extent-property extent 'help-echo (cond
  264.                         ((and href (or client-map
  265.                                    server-map))
  266.                          (format "%s [map]" href))
  267.                         (href href)
  268.                         (t nil)))
  269.     (set-glyph-property glyph 'widget widget)))))
  270.  
  271. (defun widget-image-delete (widget)
  272.   ;; Remove the widget from the buffer
  273.   (let ((extent (widget-get widget 'extent))
  274.     (child  (car (widget-get widget :children))))
  275.     (cond
  276.      (extent                ; Remove a glyph
  277.       (delete-extent extent))
  278.      (child                ; Remove a child widget
  279.       (widget-apply child :delete))
  280.      (t                    ; Doh!  Do nothing.
  281.       nil))))     
  282.  
  283. (if (fboundp 'mouse-event-p)
  284.     (fset 'widget-mouse-event-p 'mouse-event-p)
  285.   (fset 'widget-mouse-event-p 'ignore))
  286.  
  287. (if (fboundp 'glyphp)
  288.     (fset 'widget-glyphp 'glyphp)
  289.   (fset 'widget-glyphp 'ignore))
  290.  
  291. (defun widget-image-button-press (event)
  292.   (interactive "@e")
  293.   (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
  294.      (widget (and glyph (glyph-property glyph 'widget))))
  295.     (widget-image-notify widget widget event)))    
  296.  
  297. (defun widget-image-usemap-default (usemap)
  298.   (let ((rval (and usemap (car usemap))))
  299.     (while usemap
  300.       (if (equal (aref (car usemap) 0) "default")
  301.       (setq rval (car usemap)
  302.         usemap nil))
  303.       (setq usemap (cdr usemap)))
  304.     rval))
  305.  
  306. (defun widget-image-summarize (widget)
  307.   (if (widget-get widget :parent)
  308.       (setq widget (widget-get widget :parent)))
  309.   (let* ((ismap  (widget-get widget 'ismap))
  310.      (usemap (widget-image-usemap widget))
  311.      (href   (widget-get widget :href))
  312.      (alt    (widget-get widget 'alt))
  313.      (value  (widget-value widget)))
  314.     (cond
  315.      (usemap
  316.       (setq usemap (widget-image-usemap-default usemap))
  317.       ;; Perhaps we should do something here with showing the # of entries
  318.       ;; in the imagemap as well as the default href?  Could get too long.
  319.       (format "Client side imagemap: %s" value))
  320.      (ismap
  321.       (format "Server side imagemap: %s" href))
  322.      ((stringp href)            ; Normal hyperlink
  323.       (format "Image hyperlink: %s" href))
  324.      ((stringp alt)            ; Alternate message was specified
  325.       (format "Image: %s" alt))
  326.      ((stringp value)
  327.       (format "Image: %s" value))
  328.      (t                    ; Huh?
  329.       "A very confused image widget."))))
  330.  
  331. (defvar widget-image-auto-retrieve 'ask
  332.   "*Whether to automatically retrieve the source of an image widget
  333. if it is not an active hyperlink or imagemap.
  334. If `nil', don't do anything.
  335. If `t', automatically retrieve the source.
  336. Any other value means ask the user each time.")
  337.  
  338. (defun widget-image-notify (widget widget-changed &optional event)
  339.   ;; Happens when anything changes
  340.   (let* ((glyph (and event (widget-mouse-event-p event) (event-glyph event)))
  341.      (x (and glyph (event-glyph-x-pixel event)))
  342.      (y (and glyph (event-glyph-y-pixel event)))
  343.      (ismap  (widget-get widget 'ismap))
  344.      (usemap (widget-image-usemap widget))
  345.      (href   (widget-get widget :href))
  346.      (img-src (or (widget-get widget :src)
  347.               (and widget-changed (widget-get widget-changed :src))))
  348.      (target (widget-get widget :target))
  349.      )
  350.     (if target (setq target (intern (downcase target))))
  351.     (cond
  352.      ((and glyph usemap)        ; Do the client-side imagemap stuff
  353.       (setq href (w3-point-in-map (vector x y) usemap nil))
  354.       (if (stringp href)
  355.       (w3-fetch href target)
  356.     (message "No destination found for %d,%d" x y)))
  357.      ((and glyph x y ismap)        ; Do the server-side imagemap stuff
  358.       (w3-fetch (format "%s?%d,%d" href x y) target))
  359.      (usemap                ; Dummed-down tty client side imap
  360.       (let ((choices (mapcar (function
  361.                   (lambda (entry)
  362.                 (cons
  363.                  (or (aref entry 3) (aref entry 2))
  364.                  (aref entry 2)))) usemap))
  365.         (choice nil)
  366.         (case-fold-search t))
  367.     (setq choice (completing-read "Imagemap: " choices nil t)
  368.           choice (cdr-safe (assoc choice choices)))
  369.     (and (stringp choice) (w3-fetch choice target))))
  370.      (ismap                ; Do server-side dummy imagemap for tty
  371.       (w3-fetch (concat href "?0,0") target))
  372.      ((stringp href)            ; Normal hyperlink
  373.       (w3-fetch href target))
  374.      ((stringp img-src)
  375.       (cond
  376.        ((null widget-image-auto-retrieve) nil)
  377.        ((eq t widget-image-auto-retrieve)
  378.     (w3-fetch img-src))
  379.        ((funcall url-confirmation-func
  380.          (format "Retrieve image (%s)?"
  381.              (url-truncate-url-for-viewing img-src)))
  382.     (w3-fetch img-src))))
  383.      (t                    ; Huh?
  384.       nil))))
  385.  
  386. (provide 'w3-widget)
  387.